home *** CD-ROM | disk | FTP | other *** search
- PROGRAM settime ;
- { program to set the date and time in auto folder }
- { this makes sure that the time is always correct }
- { written in OSS Pesonal Pascal by William R. Good }
- { July 1986 used by permission from OSS }
-
- CONST
- {$I GEMCONST.PAS}
-
- TYPE
- {$I gemtype.pas}
-
- VAR
- dialog : Dialog_Ptr ;
- dateint, timeint : integer ;
- date, time : string ;
- datestring, timestring : string[255] ;
-
- {$I gemsubs}
-
- { had to use these two XBIOS functions because }
- { the GEMDOS calls did not work in auto folder }
- { if anybody has a reason for this leave email }
- { on genie thanks William R. Good }
-
- FUNCTION getimedate : Long_Integer ;
- XBIOS( 23 ) ;
-
- PROCEDURE fixtime( dateintg, timeintg : integer ) ;
- XBIOS( 22 ) ;
-
- PROCEDURE stoi ( var int : integer ; inttext : string ) ;
- { Takes the string "inttext" and converts it to the integer }
- { "int". used to get a value out of a dialog box }
-
- var
- len, index, dummy : integer ;
- begin
- int := 0 ;
- len := length ( inttext ) ;
- for index := 1 to len do
- begin
- int := (10*int)+(ord(inttext[index])-ord('0')) ;
- end ;
- end ; {stoi}
-
- PROCEDURE Inttostr (int : integer; VAR inttext : string);
- {Generic procedure to convert integers to strings, packs front with zeros.}
-
- VAR
- place,digit : integer;
- tempstr : string ;
- BEGIN
- tempstr := '' ;
- FOR place:=1 DOWNTO 0 DO
- BEGIN
- digit:=int DIV Round(PwrOfTen(place));
- tempstr := concat (tempstr, chr(digit+ord('0'))) ;
- int:=int MOD Round(PwrOfTen(place));
- END;
- inttext := tempstr ;
- END; {Inttostr}
-
- PROCEDURE getdatetime (var datestr, timestr : string ) ;
- { procedure to return the date & time in a string }
-
- VAR
- ldateint, ltempint, ltmpint : long_integer ;
- dateint, timeint, tempint, tmpint,
- hourint, minint, secint,
- yearint, monthint, dayint : integer ;
- hourstr, minstr, secstr,
- yearstr, monthstr, daystr : string ;
- BEGIN
- ldateint := getimedate ;
- ltempint := shr( ldateint, 16 ) ;
- dateint := int( ltempint ) ;
- yearint := dateint div 512 ;
- yearint := yearint + 80 ;
- tempint := dateint mod 512 ;
- monthint := tempint div 32 ;
- dayint := tempint mod 32 ;
- inttostr( yearint, yearstr ) ;
- inttostr( monthint, monthstr ) ;
- inttostr( dayint, daystr ) ;
- datestr := concat( monthstr, daystr, yearstr ) ;
-
- ltempint := shl( ldateint, 15 ) ;
- ltmpint := shr( ltempint , 15 ) ;
- timeint := int( ltmpint ) ;
- hourint := timeint div $800 ;
- tempint := timeint mod $800 ;
- minint := tempint div $20 ;
- secint := tempint mod $20;
- secint := secint * 2 ;
- hourint := hourint + tmpint ;
- inttostr( hourint, hourstr ) ;
- inttostr( minint, minstr ) ;
- inttostr( secint, secstr ) ;
- timestr := concat( hourstr, minstr, secstr ) ;
- END ; { getdatetime }
-
- procedure settime ( var timeint: integer ; timestr : string ) ;
- { sets the time in the machine }
-
- var
- tempint, testtime,
- hourint, minint, secint : integer ;
- hourstr, minstr, secstr : string ;
- begin
- secstr := copy( timestr, 5, 2 ) ;
- minstr := copy( timestr, 3, 2 ) ;
- hourstr := copy( timestr, 1, 2 ) ;
- stoi ( hourint, hourstr ) ;
- stoi ( minint, minstr ) ;
- stoi ( secint, secstr ) ;
- hourint := hourint * $800 ;
- minint := minint * $20 ;
- timeint := hourint + minint + secint ;
- end ; { settime }
-
- procedure setdate ( var dateint : integer ; datestr : string ) ;
- { sets the date in the machine }
-
- var
- testdate, tempint, tmpint,
- yearint, monthint, dayint : integer ;
- yearstr, monthstr, daystr : string ;
- begin
- daystr := copy( datestr, 3, 2 ) ;
- monthstr := copy( datestr, 1, 2 ) ;
- yearstr := copy( datestr, 5, 2 ) ;
- stoi ( yearint, yearstr ) ;
- stoi ( monthint, monthstr ) ;
- stoi ( dayint, daystr ) ;
- yearint := yearint - 80 ;
- yearint := yearint * 512 ;
- monthint := monthint * 32 ;
- dateint := yearint + monthint + dayint ;
- end ; { setdate }
-
- BEGIN { main }
- date := '' ;
- time := '' ;
- getdatetime ( date, time ) ;
- writeln ( ' Settime by William R. Good ver 1.0 ' ) ;
- writeln ( ' Portions of this product are ' ) ;
- writeln ( ' Copyright (c) 1986 OSS and CCD ' ) ;
- writeln ( ' Used by Permission of OSS ' ) ;
- writeln ( ' Written on 07-26-86 ' ) ;
- writeln ;
- writeln ( ' Press Return two times if no change' ) ;
- writeln ;
- writeln ( ' date : ', date, ' time : ', time ) ;
- writeln ;
- write ( ' please enter date MMDDYY :' ) ;
- readln ( datestring ) ;
- writeln ;
- write ( ' please enter time HHMMSS :' ) ;
- readln ( timestring ) ;
- setdate ( dateint, datestring ) ;
- settime ( timeint, timestring ) ;
- fixtime ( dateint, timeint ) ;
- END. { settime }
-